home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 050 / turbtool.arc / CHAPTER2.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1985-04-01  |  6.4 KB  |  330 lines
  1. {$A-}
  2. PROGRAM chapter2;
  3. {$I TOOLU.PAS}
  4. var cmdptr:file;
  5. PROCEDURE TRANSLIT;FORWARD;
  6. PROCEDURE ENTAB;FORWARD;
  7. PROCEDURE EXPAND;FORWARD;
  8. PROCEDURE ECHO;FORWARD;
  9. PROCEDURE COMPRESS;FORWARD;
  10. PROCEDURE OVERSTRIKE;FORWARD;
  11.  
  12.  
  13. PROCEDURE OVERSTRIKE;
  14. CONST
  15.   SKIP=BLANK;
  16.   NOSKIP=PLUS;
  17. VAR
  18.   C:CHARACTER;
  19.   COL,NEWCOL,I:INTEGER;
  20. BEGIN
  21.   COL:=1;
  22.   REPEAT
  23.     NEWCOL:=COL;
  24.     WHILE(GETC(C)=BACKSPACE) DO
  25.       NEWCOL:=MAX(NEWCOL-1,1);
  26.     IF (NEWCOL<COL) THEN BEGIN
  27.       PUTC(NEWLINE);
  28.       PUTC(NOSKIP);
  29.       FOR I:=1 TO NEWCOL-1 DO
  30.         PUTC(BLANK);
  31.       COL:=NEWCOL
  32.     END
  33.     ELSE IF (COL=1) AND (C<>ENDFILE) THEN
  34.       PUTC(SKIP);
  35.     IF(C<>ENDFILE)THEN BEGIN
  36.       PUTC(C);
  37.       IF (C=NEWLINE) THEN
  38.         COL:=1
  39.       ELSE
  40.         COL:=COL+1
  41.       END
  42.     UNTIL (C=ENDFILE)
  43.   END;
  44.  
  45. PROCEDURE COMPRESS;
  46. CONST
  47.   WARNING=CARET;
  48. VAR
  49.   C,LASTC:CHARACTER;
  50.   N:INTEGER;
  51.  
  52. PROCEDURE PUTREP(N:INTEGER;C:CHARACTER);CONST
  53.   MAXREP=26;
  54.   THRESH=4;
  55. BEGIN
  56.   WHILE(N>=THRESH)OR((C=WARNING)AND(N>0))DO BEGIN
  57.     PUTC(WARNING);
  58.     PUTC(MIN(N,MAXREP)-1+ORD('A'));
  59.     PUTC(C);
  60.     N:=N-MAXREP
  61.   END;
  62.   FOR N:=N DOWNTO 1 DO
  63.     PUTC(C)
  64.   END;
  65.  
  66. BEGIN(*COMPRESS*)
  67.   N:=1;
  68.   LASTC:=GETC(LASTC);
  69.   WHILE(LASTC<>ENDFILE) DO BEGIN
  70.     IF(GETC(C)=ENDFILE)THEN BEGIN
  71.       IF(N>1) OR(LASTC=WARNING) THEN
  72.         PUTREP(N,LASTC)
  73.       ELSE
  74.         PUTC(LASTC)
  75.       END
  76.       ELSE IF (C=LASTC) THEN
  77.         N:=N+1
  78.       ELSE IF (N>1) OR (LASTC=WARNING) THEN BEGIN
  79.         PUTREP(N,LASTC);
  80.         N:=1
  81.       END
  82.       ELSE
  83.          PUTC(LASTC);
  84.       LASTC:=C
  85.     END
  86.   END;
  87.   
  88.   PROCEDURE EXPAND;
  89.   CONST
  90.     WARNING=CARET;
  91.    VAR
  92.      C:CHARACTER;
  93.      N:INTEGER;
  94.   BEGIN
  95.     WHILE(GETC(C)<>ENDFILE) DO
  96.       IF (C<>WARNING)THEN
  97.         PUTC(C)
  98.       ELSE IF(ISUPPER(GETC(C))) THEN BEGIN
  99.         N:=C-ORD('A')+1;
  100.         IF(GETC(C)<>ENDFILE)THEN
  101.           FOR N:=N DOWNTO 1 DO
  102.             PUTC(C)
  103.           ELSE BEGIN
  104.             PUTC(WARNING);
  105.             PUTC(N-1+ORD('A'))
  106.           END
  107.       END
  108.       ELSE BEGIN
  109.         PUTC(WARNING);
  110.         IF(C<>ENDFILE) THEN
  111.           PUTC(C)
  112.       END
  113.   END;
  114.  
  115.  
  116. PROCEDURE ECHO;
  117. VAR
  118.   I,J:INTEGER;
  119.   ARGSTR:XSTRING;
  120. BEGIN
  121.   I:=2;
  122.   WHILE(GETARG(I,ARGSTR,MAXSTR))DO BEGIN
  123.     IF(I>1) THEN PUTC(BLANK);
  124.     FOR J:=1 TO XLENGTH(ARGSTR) DO
  125.       PUTC(ARGSTR[J]);
  126.     I:=I+1
  127.   END;
  128.   IF(I>1)THEN PUTC(NEWLINE)
  129. END;
  130.  
  131.  
  132.  
  133. PROCEDURE ENTAB;
  134. CONST
  135.   MAXLINE=1000;
  136. TYPE
  137.   TABTYPE=ARRAY[1..MAXLINE] OF BOOLEAN;
  138. VAR
  139.   C:CHARACTER;
  140.   COL,NEWCOL:INTEGER;
  141.   TABSTOPS:TABTYPE;
  142.  
  143. FUNCTION TABPOS(COL:INTEGER;VAR TABSTOPS:TABTYPE):BOOLEAN;
  144. BEGIN
  145.   IF(COL>MAXLINE)THEN
  146.     TABPOS:=TRUE
  147.   ELSE
  148.     TABPOS:=TABSTOPS[COL]
  149. END;
  150.  
  151. PROCEDURE SETTABS(VAR TABSTOPS:TABTYPE);
  152. CONST
  153.   TABSPACE=4;
  154. VAR
  155.   I:INTEGER;
  156. BEGIN
  157.   FOR I:=1 TO MAXLINE DO
  158.     TABSTOPS[I]:=(I MOD TABSPACE = 1)
  159. END;
  160.  
  161.     BEGIN
  162.   SETTABS(TABSTOPS);
  163.   COL:=1;
  164.   REPEAT
  165.     NEWCOL:=COL;
  166.     WHILE(GETC(C)=BLANK) DO BEGIN
  167.       NEWCOL:=NEWCOL+1;
  168.       IF(TABPOS(NEWCOL,TABSTOPS))THEN BEGIN
  169.         PUTC(TAB);
  170.         COL:=NEWCOL;
  171.       END
  172.     END;
  173.     WHILE (COL<NEWCOL) DO BEGIN
  174.       PUTC(BLANK);
  175.       COL:=COL+1
  176.     END;
  177.     IF(C<>ENDFILE) THEN BEGIN
  178.       PUTC(C);
  179.       IF(C=NEWLINE) THEN
  180.         COL:=1
  181.       ELSE
  182.         COL:=COL+1
  183.       END
  184.     UNTIL(C=ENDFILE)
  185.   END;
  186.  
  187.  
  188.  
  189. PROCEDURE TRANSLIT;
  190. CONST
  191.   NEGATE=CARET;
  192. VAR
  193.   ARG,FROMSET,TOSET:XSTRING;
  194.   C:CHARACTER;
  195.   I,LASTTO:0..MAXSTR;
  196.   ALLBUT,SQUASH:BOOLEAN;
  197. FUNCTION XINDEX(VAR INSET:XSTRING;C:CHARACTER;
  198.   ALLBUT:BOOLEAN;LASTTO:INTEGER):INTEGER;
  199. BEGIN
  200.   IF(C=ENDFILE)THEN XINDEX:=0
  201.   ELSE IF (NOT ALLBUT) THEN
  202.     XINDEX:=INDEX(INSET,C)
  203.   ELSE IF(INDEX(INSET,C)>0)THEN
  204.     XINDEX:=0
  205.   ELSE
  206.     XINDEX:=LASTTO+1
  207. END;
  208.   
  209. FUNCTION MAKESET(VAR INSET:XSTRING;K:INTEGER;
  210.   VAR OUTSET:XSTRING;MAXSET:INTEGER):BOOLEAN;
  211.  
  212. VAR J:INTEGER;
  213.  
  214. PROCEDURE DODASH(DELIM:CHARACTER;VAR SRC:XSTRING;
  215.   VAR I:INTEGER;VAR DEST:XSTRING;
  216.   VAR J:INTEGER;MAXSET:INTEGER);
  217. VAR
  218.   K:INTEGER;
  219.   JUNK:BOOLEAN;
  220. BEGIN
  221.   WHILE (SRC[I]<>DELIM)AND(SRC[I]<>ENDSTR)DO BEGIN
  222.     IF(SRC[I]=ATSIGN)THEN
  223.       JUNK:=ADDSTR(ESC(SRC,I),DEST,J,MAXSET)
  224.     ELSE IF (SRC[I]<>DASH) THEN
  225.       JUNK:=ADDSTR(SRC[I],DEST,J,MAXSET)
  226.     ELSE IF (J<=1)OR(SRC[I+1]=ENDSTR)THEN
  227.       JUNK:=ADDSTR(DASH,DEST,J,MAXSET)
  228.     ELSE IF (ISALPHANUM(SRC[I-1]))
  229.       AND (ISALPHANUM(SRC[I+1]))
  230.       AND (SRC[I-1]<=SRC[I+1]) THEN BEGIN
  231.         FOR K:=SRC[I-1]+1 TO SRC[I+1] DO
  232.           JUNK:=ADDSTR(K,DEST,J,MAXSET);
  233.         I:=I+1
  234.       END
  235.     ELSE
  236.       JUNK:=ADDSTR(DASH,DEST,J,MAXSET);
  237.     I:=I+1
  238.   END
  239.   
  240. END;(*DODASH*)
  241.  
  242. BEGIN(*MAKESET*)
  243.   J:=1;
  244.   DODASH(ENDSTR,INSET,K,OUTSET,J,MAXSET);
  245.   MAKESET:=ADDSTR(ENDSTR,OUTSET,J,MAXSET)
  246. END;(*MAKESET*)
  247.  
  248. BEGIN(*TRANSLIT*)
  249.   IF (NOT GETARG(2,ARG,MAXSTR))THEN
  250.     ERROR('USAGE:TRANSLIT FROM TO');
  251.   ALLBUT:=(ARG[1]=NEGATE);
  252.   IF(ALLBUT)THEN
  253.     I:=2
  254.   ELSE
  255.     I:=1;
  256.   IF (NOT MAKESET(ARG,I,FROMSET,MAXSTR)) THEN
  257.     ERROR('TRANSLIT:"FROM"SET TOO LARGE');
  258.   IF(NOT GETARG(3,ARG,MAXSTR))THEN
  259.     TOSET[1]:=ENDSTR
  260.   ELSE IF (NOT MAKESET(ARG,1,TOSET,MAXSTR)) THEN
  261.     ERROR('TRANSLIT:"TO"SET TOO LARGE')
  262.   ELSE IF (XLENGTH(FROMSET)<XLENGTH(TOSET))THEN
  263.     ERROR('TRANSLIT:"FROM"SHORTER THAN "TO');
  264.   
  265.   LASTTO:=XLENGTH(TOSET);
  266.   SQUASH:=(XLENGTH(FROMSET)>LASTTO) OR (ALLBUT);
  267.   REPEAT
  268.     I:=XINDEX(FROMSET,GETC(C),ALLBUT,LASTTO);
  269.     IF (SQUASH) AND(I>=LASTTO) AND (LASTTO>0) THEN BEGIN
  270.       PUTC(TOSET[LASTTO]);
  271.       REPEAT
  272.         I:=XINDEX(FROMSET,GETC(C),ALLBUT,LASTTO)
  273.       UNTIL (I<LASTTO)
  274.     END;
  275.     IF(C<>ENDFILE) THEN BEGIN
  276.       IF(I>0)AND(LASTTO>0) THEN
  277.         PUTC(TOSET[I])
  278.       ELSE IF (I=0)THEN
  279.         PUTC(C)
  280.       (*ELSE DELETE*)
  281.     END
  282.   UNTIL(C=ENDFILE)
  283. END;
  284.   
  285.  
  286.  
  287.  
  288.  
  289.  
  290.  
  291. PROCEDURE COMMAND;
  292. VAR I:INTEGER;XS:XSTRING;B:BOOLEAN;
  293. S:PACKED ARRAY[1..3]OF CHAR;
  294.  
  295. BEGIN
  296.   B:=GETARG(1,XS,MAXSTR);
  297.   IF (B=TRUE)THEN BEGIN
  298.     for i:=1 to 3 do begin
  299.       if islower(xs[i])then s[i]:=chr(xs[i]-32) else
  300.       s[i]:=chr(xs[i])
  301.     end;
  302.   END
  303.   ELSE BDOS(0,0);
  304.   
  305.   IF (S=
  306.   'ENT') THEN ENTAB
  307. ELSE IF (S=
  308.   'OVE') THEN OVERSTRIKE
  309. ELSE IF (S=
  310.   'COM') THEN COMPRESS
  311. ELSE IF (S='EXP') THEN EXPAND
  312. ELSE IF (S=
  313.   'ECH') THEN ECHO
  314. ELSE IF (S=
  315.   'TRA') THEN TRANSLIT
  316. END;(*COMMAND*)
  317.  
  318.  
  319.  
  320.  
  321.  
  322. BEGIN
  323.     COMMAND;
  324.     ENDCMD;assign(cmdptr,'SHELL.COM');execute(cmdptr)
  325.  
  326. END.
  327.  
  328.  
  329.  
  330.